COMMENT ⊗   VALID 00003 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 2 Way Matcher
C00011 00003	 Here are the macros which define the simple tree structure case
C00016 ENDMK
C⊗;
;;; 2 Way Matcher
;;; Here are the macros which define the simple hunk structure case

(DECLARE (FASLOAD STRUCT FAS DSK (MAC LSP)))
(DECLARE (SETQ DEFMACRO-FOR-COMPILING ()))

(DEFSTRUCT MSTATE 
	   CURRENT-OBJECT
	   STACK
	   (PUNTED ())
	   (NULLP ())
	   (ATOMIC ())
	   H-STRUCT 
	   (SIZE 0) 
	   (CURRENT-INDEX 0) )

(DEFUN %%ADVANCE (N SIZE)
       (COND ((= N (1- SIZE)) 0)
	     (T (1+ N))))

(DEFUN D-ATOMIC (X) 
       (ATOMIC X))

(DEFUN D-CURRENT-ATOMIC (X)
       (NOT (HUNKP (CURRENT-OBJECT X))))

(DEFUN D-UNDECOMPOSABLE (X)
       (OR (NULL X)(ATOM X)(NULLP X) (ATOMIC X)))

(DEFMACRO D-CURRENT (X) 
       `(CURRENT-OBJECT ,X))

(DEFMACRO D-CURRENT-OBJECT (X) 
       `(CURRENT-OBJECT ,X))


(DEFUN D-ADVANCE (X)
       (COND ((PUNTED X)
	      (MAKE-MSTATE NULLP (NULL X)
			   ATOMIC ()
			   STACK (CDR (STACK X))
			   PUNTED T
			   CURRENT-OBJECT (CAR (STACK X))
			   SIZE (SIZE X)
			   CURRENT-INDEX 0
			   H-STRUCT ()))
	     (T (LET ((N (%%ADVANCE (CURRENT-INDEX X)
				    (SIZE X))))
		     (MAKE-MSTATE NULLP (= 0 (CURRENT-INDEX X))
				  ATOMIC ()
				  STACK ()
				  PUNTED ()
				  CURRENT-OBJECT (CXR N (H-STRUCT X))
				  SIZE (SIZE X)
				  CURRENT-INDEX N
				  H-STRUCT (H-STRUCT X))))))

(DEFMACRO D-VAR-TYPE (ATOM) 
	  ;; returns the 1st character of a D-atomic object
	  `(COND ((EQ (TYPEP ,ATOM) 'SYMBOL) (GETCHAR ,ATOM 1.))))

(DEFMACRO D-CHANGE-CURRENT (X Y) `(PROGN (SETF (CURRENT-OBJECT ,X) ,Y)
					 ,X))

(DEFUN D-CHANGE (X Y) 
 (COND ((HUNKP Y)
	(MAKE-MSTATE NULLP ()
		     ATOMIC ()
		     STACK ()
		     PUNTED ()
		     CURRENT-OBJECT (CXR 1 Y)
		     SIZE (HUNKSIZE Y)
		     CURRENT-INDEX 1
		     H-STRUCT Y)) 
       (T
	(MAKE-MSTATE NULLP (NULL Y)
		     ATOMIC T
		     STACK ()
		     PUNTED ()
		     CURRENT-OBJECT Y
		     SIZE 0
		     CURRENT-INDEX 0
		     H-STRUCT ())) ))

(DEFMACRO D-RESTRICT-VAR (X) `(CADR ,X))

(DEFUN D-MAP-BUILD (FUN H)
 (COND ((NULLP H) ())
       (T (CONS (FUNCALL FUN (CURRENT-OBJECT H))
		(D-MAP-BUILD FUN (D-ADVANCE H))))))

(DEFMACRO D-CURRENT-EMPTY (X) `(NULL (CURRENT-OBJECT ,X)))

(DEFMACRO D-EMPTY (X) `(NULLP ,X))

(DEFUN D-LISTIFY (X)
       (COND ((NULLP X) ())
	     ((PUNTED X) (STACK X))
	     (T (LET ((SIZE (SIZE X))
		      (H (H-STRUCT X)))
		     (DO ((I (CURRENT-INDEX X) (%%ADVANCE I SIZE))
			  (A ()))
			 ((= 0 I) (CONS (CXR 0 H) (NREVERSE A)))
			 (PUSH (CXR I H) A))))))

(DEFUN D-LISTIFY-REST (X)
       (COND ((NULLP X) ())
	     ((PUNTED X) (STACK X))
	     (T (LET ((SIZE (SIZE X))
		      (H (H-STRUCT X)))
		     (DO ((I (%%ADVANCE (CURRENT-INDEX X) SIZE) 
			     (%%ADVANCE I SIZE))
			  (A ()))
			 ((= 0 I) (CONS (CXR 0 H) (NREVERSE A)))
			 (PUSH (CXR I H) A))))))

(DEFMACRO D-RESTRICT-FUNS (X) `(CDDR ,X))

(DEFMACRO D-RESTRICTP (%/#X) `(AND (EQ (TYPEP ,%/#X) 'LIST)
				   (MEMQ (CAR ,%/#X) 
					 '($R RESTRICT ⊗R $IR IRESTRICT ⊗IR))))

(DEFMACRO D-IRESTRICTP (%/#X) `(AND (EQ (TYPEP ,%/#X) 'LIST)
				   (MEMQ (CAR ,%/#X) 
					 '($IR IRESTRICT ⊗IR))))


(DEFMACRO D-FRESTRICTP (%/#X) `(AND (EQ (TYPEP ,%/#X) 'LIST)
				   (MEMQ (CAR ,%/#X) 
					 '($R RESTRICT ⊗R))))

(DEFMACRO D-RESTRICT-VAR (X) `(CADR ,X))


(DEFMACRO D-RESTRICT-TYPE (X) `(CAR ,X))

(DEFMACRO D-CREATE-RESTRICTION (X Y Z)
	  `(CONS ,X (CONS ,Y  ,Z)))

(DEFUN D-ADD-ITEM (X ITEM)
 (MAKE-MSTATE 
	   CURRENT-OBJECT ITEM
	   STACK (CONS (CURRENT-OBJECT X) (STACK X))
	   PUNTED (PUNTED X)
	   NULLP ()
	   ATOMIC (ATOMIC X)
	   H-STRUCT  (H-STRUCT X)
	   SIZE (SIZE X)
	   CURRENT-INDEX (CURRENT-INDEX X)))

(DEFUN D-ADD-ITEMS (X ITEMS)
 (MAKE-MSTATE 
	   CURRENT-OBJECT (CAR ITEMS)
	   STACK (APPEND (CDR ITEMS)
			 (CONS (CURRENT-OBJECT X) (STACK X)))
	   PUNTED (PUNTED X)
	   NULLP ()
	   ATOMIC (ATOMIC X)
	   H-STRUCT  (H-STRUCT X)
	   SIZE (SIZE X)
	   CURRENT-INDEX (CURRENT-INDEX X)))

(DEFUN D-REST-EMPTY (X)
       (COND ((NULLP X) T)
	     ((PUNTED X) (NULL (STACK X)))
	     (T (= (CURRENT-INDEX X) 0))))

(DEFUN D-CREATE-STATE (X)
       (MAKE-MSTATE NULLP ()
		    ATOMIC ()
		    STACK ()
		    PUNTED ()
		    CURRENT-OBJECT (CXR 1 X)
		    SIZE (HUNKSIZE X)
		    CURRENT-INDEX 1
		    H-STRUCT X)))

(DEFUN D-CHANGE-CURRENT-ITEMS (X ITEMS)
       (SETF (NULLP X) ())
       (SETF (STACK X)
	     (APPEND (CDR ITEMS) (STACK X)))
       (SETF (CURRENT-OBJECT X) (CAR ITEMS))
       X)

(DEFUN D-CREATE-NULL-STATE ()
       (MAKE-MSTATE NULLP T
		    ATOMIC ()
		    STACK ()
		    PUNTED T
		    CURRENT-OBJECT ()
		    SIZE 0
		    CURRENT-INDEX 0
		    H-STRUCT ()))

(DEFUN D-CREATE-STATE-FROM-CURRENT (X)
       (LET ((Y (CURRENT-OBJECT X)))
	    (COND ((HUNKP Y)
		   (MAKE-MSTATE NULLP ()
				ATOMIC ()
				STACK ()
				PUNTED ()
				CURRENT-OBJECT (CXR 1 Y)
				SIZE (HUNKSIZE Y)
				CURRENT-INDEX 1
				H-STRUCT Y)) 
		  (T
		   (MAKE-MSTATE NULLP (NULL Y)
				ATOMIC T
				STACK ()
				PUNTED ()
				CURRENT-OBJECT Y
				SIZE 0
				CURRENT-INDEX 0
				H-STRUCT ())) )))

(DEFMACRO D-CHECK (X) X)

;;; Here are the macros which define the simple tree structure case

(DEFMACRO P-ATOMIC (X) `(ATOM ,X))

(DEFMACRO P-UNDECOMPOSABLE (X)
	  `(OR (ATOM ,X) 
	       (HUNKP ,X)))

(DEFMACRO P-CURRENT (X) `(CAR ,X))

(DEFMACRO P-CURRENT-OBJECT (X) X)

(DEFMACRO P-ADVANCE (X) `(CDR ,X))

(DEFMACRO P-VAR-TYPE (ATOM) 
	  ;; returns the 1st character of an atom.
	  `(COND ((EQ (TYPEP ,ATOM) 'SYMBOL) (GETCHAR ,ATOM 1.))))

(DEFMACRO P-CHANGE-CURRENT (X Y) `(CONS ,Y (CDR ,X)))

(DEFMACRO P-CHANGE (X Y) Y)

(DEFMACRO P-RESTRICT-VAR (X) `(CADR ,X))

(DEFUN P-MAP-BUILD (FUN LIST)
       (COND ((NULL LIST) ())
	     (T (CONS (FUNCALL FUN (CAR LIST))
		      (P-MAP-BUILD FUN (CDR LIST))))))

(DEFMACRO P-CURRENT-EMPTY (X) `(NULL (CAR ,X)))

(DEFMACRO P-EMPTY (X) `(NULL ,X))

(DEFMACRO P-LISTIFY (X) X)

(DEFMACRO P-LISTIFY-REST (X) `(CDR ,X))

(DEFMACRO P-RESTRICT-FUNS (X) `(CDDR ,X))

(DEFMACRO P-RESTRICTP (%/#X) `(AND (NOT (ATOM ,%/#X))
				   (MEMQ (CAR ,%/#X) 
					 '($R RESTRICT ⊗R $IR IRESTRICT ⊗IR))))

(DEFMACRO P-IRESTRICTP (%/#X) `(AND (NOT (ATOM ,%/#X))
				   (MEMQ (CAR ,%/#X) 
					 '($IR IRESTRICT ⊗IR))))

(DEFMACRO P-FRESTRICTP (%/#X) `(AND (NOT (ATOM ,%/#X))
				   (MEMQ (CAR ,%/#X) 
					 '($R RESTRICT ⊗R))))

(DEFMACRO P-RESTRICT-VAR (X) `(CADR ,X))

(DEFMACRO P-RESTRICT-TYPE (X) `(CAR ,X))

(DEFMACRO P-CREATE-RESTRICTION (X Y Z)
	  `(CONS ,X (CONS ,Y  ,Z)))

(DEFMACRO P-ADD-ITEM (X ITEMS)
	  `(CONS ,ITEMS ,X))

(DEFMACRO P-ADD-ITEMS (X ITEMS)
	  `(APPEND ,ITEMS ,X))

(DEFMACRO P-REST-EMPTY (X) `(NULL (CDR ,X)))

(DEFMACRO P-CREATE-STATE (X) X)

(DEFMACRO P-CHANGE-CURRENT-ITEMS (X ITEMS)
	  `(APPEND ,ITEMS (CDR ,X)))

(DEFMACRO P-CREATE-NULL-STATE () ())

(DEFMACRO P-CREATE-STATE-FROM-CURRENT (X) `(CAR ,X))

(DEFMACRO P-CURRENT-ATOMIC (X) `(ATOM (CAR ,X)))

(DECLARE (SPECIAL -SEENR- -SEEN-))

(DEFMACRO CONSP (X) `(EQ (TYPEP ,X) 'LIST))

(DEFUN P-CHECK (L)
  ((LAMBDA (-SEEN- -SEENR-)
    (P-CHECK1 L)) ()())) 

(DEFUN P-CHECK1 (L)
 (COND ((MEMQ L -SEENR-) (P-CURRENT L))
       ((P-UNDECOMPOSABLE L) (PUSH (P-CURRENT-OBJECT L) -SEENR-)
			     (PUSH L -SEENR-)
			     (P-CURRENT-OBJECT L))
       ((P-ATOMIC L) (P-CURRENT-OBJECT L))
       ((AND (CONSP (P-CURRENT L))
	     (EQ (P-CURRENT L) '-SPECIAL-FORM-))
	(P-ADVANCE L))
       (T 
	(LET ((X (P-MAP-BUILD #'P-CHECK1 L)))
	     (PUSH L -SEENR-)
	     (PUSH X -SEEN-) X)))) 

(EVAL-WHEN (COMPILE EVAL)
	   (SETQ MATCH-PREFIX '%%
		 MATCH-NAME '%UMATCH))

(INCLUDE "GMATCH.125")